home *** CD-ROM | disk | FTP | other *** search
/ Tech Arsenal 1 / Tech Arsenal (Arsenal Computer).ISO / tek-04 / tool_inc.zip / RPNCALC.INC < prev    next >
Text File  |  1989-03-01  |  5KB  |  192 lines

  1.  
  2. (*
  3.  * Copyright 1987, 1989 Samuel H. Smith;  All rights reserved
  4.  *
  5.  * This is a component of the ProDoor System.
  6.  * Do not distribute modified versions without my permission.
  7.  * Do not remove or alter this notice or any other copyright notice.
  8.  * If you use this in your own program you must distribute source code.
  9.  * Do not use any of this in a commercial product.
  10.  *
  11.  *)
  12.  
  13. (*
  14.  * MISC_rpn_calc - post-fix calculator
  15.  *
  16.  * This is a utility library to implement a simple post-fix (rpn)
  17.  * calculator that can be used when runtime defined calculations
  18.  * need to be made.
  19.  *
  20.  *)
  21.  
  22. function MISC_rpn_calc (initial_value:      real;
  23.                         formula:            anystring): real;
  24.                            {apply RPN calculator to formula with initial_value
  25.                              on top of stack. returns final top of stack}
  26.  
  27. const
  28.    stack_limit =       10;    {maximum stack depth}
  29.  
  30.  
  31. var
  32.    stack:              array [1.. stack_limit] of real;
  33.    top:                integer;
  34.    word:               anystring;
  35.    c:                  char;
  36.    i:                  integer;
  37.    code:               integer;
  38.    v1,
  39.    v2:                 real;
  40.  
  41.  
  42.    procedure push (v:                  real);
  43.                               {push v on top of the stack}
  44.    begin
  45.       top := top + 1;
  46.  
  47.       if top > stack_limit then
  48.       begin
  49.          MISC_fatal_error('RPN Stack overflow, formula: ' + formula);
  50.          top := top -1;
  51.       end;
  52.  
  53.       stack[top]:= v;
  54.    end;
  55.  
  56.  
  57.    function pop: real;        {pop a value off the top of stack}
  58.    begin
  59.  
  60.       if top < 1 then
  61.       begin
  62.          MISC_fatal_error('RPN Stack underflow, formula: ' + formula);
  63.          top := top + 1;
  64.       end;
  65.  
  66.       pop := stack [top];
  67.       top := top - 1;
  68.    end;
  69.  
  70.    function scannum(word: anystring; radix: integer): real;
  71.    var
  72.       i:  integer;
  73.       n:  real;
  74.       d:  integer;
  75.  
  76.    begin
  77.       n := 0.0;
  78.       for i := 2 to length(word) do
  79.       begin
  80.          d := ord(upcase(word[i])) - ord('0');
  81.          if d > 9 then
  82.             d := d - 7;
  83.          n := n * int(radix) + int(d);
  84.       end;
  85.  
  86.       scannum := n;
  87.    end;
  88.  
  89.    function binval(word: anystring): real;
  90.    begin
  91.       binval := scannum(word,2);
  92.    end;
  93.  
  94.    function hexval(word: anystring): real;
  95.    begin
  96.       hexval := scannum(word,16);
  97.    end;
  98.  
  99.    function tan(r: real): real;
  100.    begin
  101.       tan := sin(r) / cos(r);
  102.    end;
  103.  
  104. begin                         {MISC_rpn_calc}
  105.  
  106.    top := 0;
  107.    push(initial_value);
  108.    word := '';
  109.  
  110.    for i := 1 to length (formula) do
  111.                               {scan the formula string}
  112.    begin
  113.       c := formula [i];
  114.  
  115.       if c <> ' ' then
  116.          word := word + upcase(c);
  117.  
  118.       if (c = ' ') or (i = length (formula)) then
  119.                                  {if at the end of a word or at the end
  120.                                    of the formula}
  121.       begin
  122.  
  123.          case word [1] of       {check for and process each operator}
  124.  
  125.             '+':  push(pop + pop);
  126.  
  127.             '*':  push(pop * pop);
  128.  
  129.             '-':  begin
  130.                      if (length(word) > 1) and (word[2] in ['0'..'9']) then
  131.                      begin
  132.                         val(word, v1, code);
  133.                         push(v1);
  134.                      end
  135.                      else
  136.                      begin
  137.                         v1 := pop;
  138.                         v2 := pop;
  139.                         push(v2 - v1);
  140.                      end;
  141.                   end;
  142.  
  143.             '/':  begin
  144.                      v1 := pop;
  145.                      v2 := pop;
  146.                      push(v2 / v1);
  147.                   end;
  148.  
  149.             '\':  begin
  150.                      v1 := pop;
  151.                      if v1 <> 0.0 then
  152.                         push(1.0 / v1)
  153.                      else
  154.                         push(0.0);
  155.                   end;
  156.  
  157.             'H':  push(hexval(word));
  158.  
  159.             'B':  push(binval(word));
  160.  
  161.             '.','0'..'9':              {numbers are pushed on the stack}
  162.                   begin
  163.                      val(word, v1, code);
  164.                      push(v1);
  165.                   end;
  166.  
  167.             else
  168.                if word = 'PI'   then push(pi)        else
  169.                if word = 'SIN'  then push(sin(pop))  else
  170.                if word = 'COS'  then push(cos(pop))  else
  171.                if word = 'TAN'  then push(tan(pop))  else
  172.                if word = 'EXP'  then push(exp(pop))  else
  173.                if word = 'INT'  then push(int(pop))  else
  174.                if word = 'SQRT' then push(sqrt(pop)) else
  175.                if word = 'LN'   then push(ln(pop))   else
  176.                if word = 'E'    then push(exp(1.0))
  177.                else
  178.                   MISC_fatal_error('Unknown RPN word: ' + word +
  179.                                    ' in formula: ' + formula);
  180.          end;
  181.  
  182.          word := '';                {consume the word and scan for more
  183.                                       words}
  184.  
  185.       end;
  186.    end;
  187.  
  188.    MISC_rpn_calc := pop;
  189.  
  190. end;                       {MISC_rpn_calc}
  191.  
  192.